home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-wic.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-07  |  52.2 KB  |  2,354 lines
  1. /*  $Id: pl-wic.c,v 1.57 1997/08/07 07:58:56 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: load and save intermediate code files
  8. */
  9.  
  10. /*#define O_DEBUG 1*/
  11. #include "pl-incl.h"
  12. #ifdef HAVE_SYS_PARAM_H
  13. #include <sys/param.h>
  14. #endif
  15. #ifdef HAVE_UNISTD_H
  16. #include <unistd.h>
  17. #endif
  18.  
  19. forwards char *    getString(IOSTREAM *);
  20. forwards long    getNum(IOSTREAM *);
  21. forwards real    getReal(IOSTREAM *);
  22. forwards bool    loadWicFd(char *, IOSTREAM *, int);
  23. forwards bool    loadPredicate(IOSTREAM *, int skip);
  24. forwards bool    loadImport(IOSTREAM *, int skip);
  25. forwards void    putString(char *, IOSTREAM *);
  26. forwards void    putAtom(atom_t, IOSTREAM *);
  27. forwards void    putNum(long, IOSTREAM *);
  28. forwards void    putReal(real, IOSTREAM *);
  29. forwards void    saveWicClause(Clause, IOSTREAM *);
  30. forwards void    closeProcedureWic(IOSTREAM *);
  31. forwards bool    closeWic(void);
  32. forwards bool    addDirectiveWic(term_t, IOSTREAM *fd);
  33. forwards bool    importWic(Procedure, IOSTREAM *fd);
  34. forwards bool    compileFile(char *);
  35. forwards bool    putStates(IOSTREAM *);
  36. forwards word    loadXR(IOSTREAM *);
  37. forwards word   loadXRc(int c, IOSTREAM *fd);
  38. forwards void    putstdw(word w, IOSTREAM *fd);
  39. forwards word    getstdw(IOSTREAM *fd);
  40. static bool    loadStatement(int c, IOSTREAM *fd, int skip);
  41. static bool    loadPart(IOSTREAM *fd, Module *module, int skip);
  42. static bool    loadInModule(IOSTREAM *fd, int skip);
  43. static int    qlfVersion(IOSTREAM *s);
  44. static bool    appendState(const char *name);
  45.  
  46. #define Qgetc(s) Snpgetc(s)        /* ignore position recording */
  47.  
  48. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  49. SWI-Prolog can compile Prolog source files into intermediate code files, 
  50. which can be loaded very  fast.   They  can  be  saved  as  stand  alone
  51. executables using Unix #! magic number.
  52.  
  53. A wic file consists of the magic code and a version check code.  This is
  54. followed by the command line option   defaults.  Then an optional series
  55. of `include' statements follow.  Finally   the predicates and directives
  56. are  described.   Predicates  are  described    close  to  the  internal
  57. representation.  Directives are stored as  binary terms representing the
  58. query.
  59.  
  60. The default options and include statements are written incrementally  in
  61. each  wic  file.   In  the  normal  boot  cycle  first  the boot file is
  62. determined.  Then the option structure is filled with the default option
  63. found in this boot file.  Next the command line arguments are scanned to
  64. obtain all options.  Then stacks, built  in's,  etc.   are  initialised.
  65. The  the  boot  file is read again, but now only scanning for directives
  66. and predicates.
  67.  
  68. IF YOU CHANGE ANYTHING TO THIS IOSTREAM, SO THAT OLD WIC-FILES CAN NO LONGER
  69. BE READ, PLEASE DO NOT FORGET TO INCREMENT THE VERSION NUMBER!
  70.  
  71. Below is an informal description of the format of a `.qlf' file:
  72.  
  73. <wic-file>    ::=    #!<path>
  74.             <magic code>
  75.             <version number>
  76.             <localSize>            % a <word>
  77.             <globalSize>            % a <word>
  78.             <trailSize>            % a <word>
  79.             <argumentSize>            % a <word>
  80.             <heapSize>            % a <word>
  81.             <goal>                % a <string>
  82.             <topLevel>            % a <string>
  83.             <initFile>            % a <string>
  84.             <home>                % a <string>
  85.             {<statement>}
  86.             'T'
  87.             <size>                % a stdword
  88.             <QLFMAGICNUM>            % a stdword
  89. ----------------------------------------------------------------
  90. <qlf-file>    ::=    <qlf-magic>
  91.             <version-number>
  92.             'F' <string>            % path of qlf file
  93.             'Q' <qlf-part>
  94. <qlf-magic>    ::=    <string>
  95. <qlf-module>    ::=    <qlf-header>
  96.             <size>                % size in bytes
  97.             {<statement>}
  98.             'X'
  99. <qlf-header>    ::=    'M' <XR/modulename>        % module name
  100.             <source>            % file + time
  101.             {<qlf-export>}
  102.             'X'
  103.               | <source>            % not a module
  104.             <time>
  105. <qlf-export>    ::=    'E' <XR/functor>
  106. <source>    ::=    'F' <string> <time> <system>
  107.               | '-'
  108. ----------------------------------------------------------------
  109. <magic code>    ::=    <string>            % normally #!<path>
  110. <version number>::=    <num>
  111. <statement>    ::=    'W' <string>            % include wic file
  112.               | 'P' <XR/functor>
  113.                 {<clause>} <pattern>    % predicate
  114.               |    'O' <XR/modulename>
  115.                 <XR/functor>        % pred out of module
  116.                 {<clause>} <pattern>
  117.               | 'D' 
  118.                 <lineno>            % source line number
  119.             <term>                % directive
  120.               | 'E' <XR/functor>        % export predicate
  121.               | 'I' <XR/procedure>        % import predicate
  122.               | 'Q' <qlf-module>        % include module
  123.               | 'M' <XR/modulename>        % load-in-module
  124.                     {<statement>}
  125.                 'X'
  126. <clause>    ::=    'C' <line_no> <# var>
  127.                 <#n subclause> <#codes> <codes>
  128.               | 'X'                 % end of list
  129. <XR>        ::=    XR_REF     <num>        % XR id from table
  130.             XR_ATOM    <string>        % atom
  131.             XR_INT     <num>        % number
  132.             XR_BIGNUM  <word>        % big-number
  133.             XR_FLOAT   <word>        % real (float)
  134.             XR_STRING  <string>        % string
  135.             XR_FUNCTOR <XR/name> <num>    % functor
  136.             XR_PRED    <XR/fdef> <XR/module>% predicate
  137. <term>        ::=    <num>                % # variables in term
  138.             <theterm>
  139. <theterm>    ::=    <XR/atomic>            % atomic data
  140.               | 'v' <num>            % variable
  141.               | 't' <XR/functor> {<theterm>}    % compound
  142. <system>    ::=    's'                % system source file
  143.               | 'u'                % user source file
  144. <time>        ::=    <word>                % time file was loaded
  145. <pattern>    ::=    <num>                % indexing pattern
  146. <codes>        ::=    <num> {<code>}
  147. <string>    ::=    {<non-zero byte>} <0>
  148. <word>        ::=    <4 byte entity>
  149.  
  150. Numbers are stored in  a  packed  format  to  reduce  the  size  of  the
  151. intermediate  code  file  as  99%  of  them  is  normally  small, but in
  152. principle not limited (virtual  machine  codes,  arities,  table  sizes,
  153. etc).   The  upper  two  bits  of  the  first byte contain the number of
  154. additional bytes.  the bytes represent the number `most-significant part
  155. first'.  See the functions putNum() and getNum()  for  details.   Before
  156. you  don't  agree  to  this  schema,  you  should  remember it makes the
  157. intermediate code files about 30% smaller  and  avoids  the  differences
  158. between  16  and  32  bits  machines (arities on 16 bits machines are 16
  159. bits) as well as machines with different byte order.
  160. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  161.  
  162. #define LOADVERSION 30            /* load all versions later >= 30 */
  163. #define VERSION 31            /* save version number */
  164. #define QLFMAGICNUM 0x716c7374        /* "qlst" on little-endian machine */
  165.  
  166. #define XR_REF     0            /* reference to previous */
  167. #define XR_ATOM       1            /* atom */
  168. #define XR_FUNCTOR 2            /* functor */
  169. #define XR_PRED       3            /* procedure */
  170. #define XR_INT     4            /* int */
  171. #define XR_BIGNUM  5            /* 32-bit integer */
  172. #define XR_FLOAT   6            /* float */
  173. #define XR_STRING  7            /* string */
  174.  
  175. static char saveMagic[] = "SWI-Prolog (c) 1990 Jan Wielemaker\n";
  176. static char qlfMagic[]  = "SWI-Prolog .qlf file\n";
  177. static char *wicFile;            /* name of output file */
  178. static char *mkWicFile;            /* Wic file under construction */
  179. static IOSTREAM *wicFd;            /* file descriptor of wic file */
  180. static Procedure currentProc;        /* current procedure */
  181. static SourceFile currentSource;    /* current source file */
  182.  
  183. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  184. On tos, loading takes long; give the user  something  to  look  at.   On
  185. workstations, it normally is so fast it is hardy noticable.
  186. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  187.  
  188. #if tos
  189. static void
  190. notifyLoad(file)
  191. char *file;
  192. { Sfprintf(Soutput, "Loading %s ", file);
  193.   Sflush(Soutput);
  194. }
  195.  
  196. static void
  197. notifyLoaded()
  198. { Sprintf(Soutput, "\r\033K");
  199. }
  200.  
  201. static void
  202. notifyPredicate(functor_t f)
  203. { static char cur[] = "|/-\\";
  204.   static int  n = 0;
  205.  
  206.   Sprintf(Soutput, "%c\b", cur[n++ & 0x3]);
  207. }
  208.  
  209. #else /*!tos*/
  210.  
  211. #define notifyLoad(file)
  212. #define notifyLoaded()
  213. #define notifyPredicate(f)
  214.  
  215. #endif /* tos */
  216.  
  217.          /*******************************
  218.          *         CLEANUP        *
  219.          *******************************/
  220.  
  221. void
  222. qlfCleanup()
  223. { if ( mkWicFile )
  224.   { warning("Removing incomplete Quick Load File %s", mkWicFile);
  225.     RemoveFile(mkWicFile);
  226.     mkWicFile = NULL;
  227.   }
  228. }
  229.  
  230.  
  231.          /*******************************
  232.          *     LOADED XR ID HANDLING    *
  233.          *******************************/
  234.  
  235. typedef struct xr_table *XrTable;
  236.  
  237. struct xr_table
  238. { int        id;            /* next id to give out */
  239.   Word           *table;            /* main table */
  240.   int       tablesize;        /* # sub-arrays */
  241.   XrTable    previous;        /* stack */
  242. };
  243.  
  244. static XrTable loadedXrs;        /* head pointer */
  245.  
  246. #define loadedXRTableId        (loadedXrs->id)
  247. #define loadedXRTable        (loadedXrs->table)
  248. #define loadedXRTableArrays    (loadedXrs->tablesize)
  249.  
  250. #define SUBENTRIES ((ALLOCSIZE)/sizeof(word))
  251.  
  252. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  253. XR reference handling during loading.  This   is arranged as an array-of
  254. arrays.  These arrays are of size ALLOCSIZE,   so they will be reused on
  255. perfect-fit basis the pl-alloc.c.  With ALLOCSIZE   = 64K, this requires
  256. minimal 128K memory.   Maximum  allowed  references   is  16K^2  or  32M
  257. references.  That will normally overflow other system limits first.
  258. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  259.  
  260. static void
  261. pushXrIdTable()
  262. { XrTable t = allocHeap(sizeof(struct xr_table));
  263.  
  264.   t->previous = loadedXrs;
  265.   loadedXrs = t;
  266.  
  267.   if ( !(loadedXRTable = malloc(ALLOCSIZE)) )
  268.     outOfCore();
  269.   loadedXRTableArrays = 0;
  270.   loadedXRTableId = 0;
  271. }
  272.  
  273.  
  274. static void
  275. popXrIdTable()
  276. { int i;
  277.   XrTable prev = loadedXrs->previous;
  278.  
  279.   for(i=0; i<loadedXRTableArrays; i++)
  280.     free(loadedXRTable[i]);
  281.  
  282.   free(loadedXRTable);
  283.   freeHeap(loadedXrs, sizeof(struct xr_table));
  284.  
  285.   loadedXrs = prev;
  286. }
  287.  
  288.  
  289. static word
  290. lookupXrId(long id)
  291. { Word array = loadedXRTable[id/SUBENTRIES];
  292.  
  293.   return array[id%SUBENTRIES];
  294. }
  295.  
  296.  
  297. static void
  298. storeXrId(long id, word value)
  299. { int i = id/SUBENTRIES;
  300.  
  301.   while ( i >= loadedXRTableArrays )
  302.   { if ( !(loadedXRTable[loadedXRTableArrays++] = malloc(ALLOCSIZE)) )
  303.       outOfCore();
  304.   }
  305.   
  306.   loadedXRTable[i][id%SUBENTRIES] = value;
  307. }
  308.  
  309.  
  310.          /*******************************
  311.          *     PRIMITIVE LOADING    *
  312.          *******************************/
  313.  
  314. static int    qlf_has_moved;        /* file has moved: be careful */
  315. static char *   qlf_save_dir;        /* dir of saved .qlf file */
  316. static char *    qlf_load_dir;        /* dir of .qlf file now */
  317.  
  318. static bool
  319. qlfLoadError(IOSTREAM *fd, char *ctx)
  320. { fatalError("%s: QLF format error at index = %ld", ctx, Stell(fd));
  321.  
  322.   fail;
  323. }
  324.  
  325.  
  326. static char *
  327. getString(IOSTREAM *fd)
  328. { static char *tmp;
  329.   static char *tmpend;
  330.   static int  tmpsize = 512;
  331.   char *s;
  332.   Char c;
  333.  
  334.   if ( tmp == NULL )
  335.   { if ( !(tmp = malloc(tmpsize)) )
  336.       outOfCore();
  337.     tmpend = &tmp[tmpsize-1];
  338.   }
  339.  
  340.   for( s = tmp; (*s = c = Getc(fd)) != EOS; s++ )
  341.   { if ( s == tmpend )
  342.     { if ( !(tmp = realloc(tmp, tmpsize+512)) )
  343.     outOfCore();
  344.       s = &tmp[tmpsize-1];
  345.       tmpsize += 512;
  346.       tmpend = &tmp[tmpsize-1];
  347.     }
  348.     if ( c == EOF )
  349.       fatalError("Unexpected EOF on intermediate code file at offset %d",
  350.          Stell(fd));
  351.   }
  352.  
  353.   return tmp;
  354. }
  355.  
  356.  
  357. static char *
  358. getMagicString(IOSTREAM *fd, char *buf, int maxlen)
  359. { char *s;
  360.   int c;
  361.  
  362.   for( s = buf; --maxlen >= 0 && (*s = (c = Getc(fd))); s++ )
  363.     if ( c == EOF )
  364.       return NULL;
  365.  
  366.   if ( maxlen > 0 )
  367.     return buf;
  368.  
  369.   return NULL;
  370. }
  371.  
  372.  
  373. static long
  374. getNum(IOSTREAM *fd)
  375. { long first = Getc(fd);
  376.   int bytes, shift, b;
  377.  
  378.   if ( !(first & 0xc0) )
  379.     return (first << 26) >> 26;        /* 99% of them: speed up a bit */    
  380.  
  381.   bytes = (int) ((first >> 6) & 0x3);
  382.   first &= 0x3f;
  383.  
  384.   for( b = 0; b < bytes; b++ )
  385.   { first <<= 8;
  386.     first |= Getc(fd) & 0xff;
  387.   }
  388.  
  389.   shift = (3-bytes)*8 + 2;
  390.  
  391.   return (first << shift) >> shift;
  392. }
  393.  
  394.  
  395. static word
  396. getstdw(IOSTREAM *fd)
  397. {
  398. #ifndef WORDS_BIGENDIAN
  399.   union
  400.   { word         l;
  401.     unsigned char c[4];
  402.   } cvrt;
  403.   long rval;
  404.  
  405.   cvrt.l = Sgetw(fd);
  406.   rval = (cvrt.c[0] << 24) |
  407.          (cvrt.c[1] << 16) |
  408.      (cvrt.c[2] << 8) |
  409.       cvrt.c[3];
  410.   return rval;
  411. #else
  412.   return Sgetw(fd);
  413. #endif
  414. }
  415.  
  416.  
  417. static real
  418. getReal(IOSTREAM *fd)
  419. { real f;
  420.   word *s = (word *) &f;
  421.  
  422. #ifndef WORDS_BIGENDIAN
  423.   s[0] = getstdw(fd);
  424.   s[1] = getstdw(fd);
  425. #else
  426.   s[1] = getstdw(fd);
  427.   s[0] = getstdw(fd);
  428. #endif
  429.  
  430.   DEBUG(3, Sdprintf("getReal() --> %f\n", f));
  431.  
  432.   return f;
  433. }
  434.  
  435.  
  436. static word
  437. loadXRc(int c, IOSTREAM *fd)
  438. { word xr;
  439.   int id = 0;                /* make gcc happy! */
  440.  
  441.   switch( c )
  442.   { case XR_REF:
  443.     { return lookupXrId(getNum(fd));
  444.     }
  445.     case XR_ATOM:
  446.       id = ++loadedXRTableId;
  447.       xr = lookupAtom(getString(fd));
  448.       DEBUG(3, Putf("XR(%d) = '%s'\n", id, stringAtom(xr)));
  449.       break;
  450.     case XR_FUNCTOR:
  451.     { atom_t name;
  452.       int arity;
  453.  
  454.       id = ++loadedXRTableId;
  455.       name = loadXR(fd);
  456.       arity = getNum(fd);
  457.       xr = (word) lookupFunctorDef(name, arity);
  458.       DEBUG(3, Putf("XR(%d) = %s/%d\n", id, stringAtom(name), arity));
  459.       break;
  460.     }
  461.     case XR_PRED:
  462.     { functor_t f;
  463.       atom_t mname;
  464.  
  465.       id = ++loadedXRTableId;
  466.       f = (functor_t) loadXR(fd);
  467.       mname = loadXR(fd);
  468.       xr = (word) lookupProcedure(f, lookupModule(mname));
  469.       DEBUG(3, Putf("XR(%d) = proc %s\n", id, procedureName((Procedure)xr)));
  470.       break;
  471.     }
  472.     case XR_INT:
  473.       return consInt(getNum(fd));
  474.     case XR_BIGNUM:
  475.       return globalLong(getstdw(fd));
  476.     case XR_FLOAT:
  477.       return globalReal(getReal(fd));
  478. #if O_STRING
  479.     case XR_STRING:
  480.       return globalString(getString(fd));
  481. #endif
  482.     default:
  483.     { xr = 0;                /* make gcc happy */
  484.       fatalError("Illegal XR entry at index %d: %c", Stell(fd)-1, c);
  485.     }
  486.   }
  487.  
  488.   storeXrId(id, xr);
  489.  
  490.   return xr;
  491. }
  492.  
  493.  
  494. static word
  495. loadXR(IOSTREAM *fd)
  496. { return loadXRc(Qgetc(fd), fd);
  497. }
  498.  
  499.  
  500. static void
  501. do_load_qlf_term(IOSTREAM *fd, term_t vars[], term_t term)
  502. { int c = Qgetc(fd);
  503.  
  504.   if ( c == 'v' )
  505.   { int id = getNum(fd);
  506.     
  507.     if ( vars[id] )
  508.       PL_unify(term, vars[id]);
  509.     else
  510.     { vars[id] = PL_new_term_ref();
  511.       PL_put_term(vars[id], term);
  512.     }
  513.   } else if ( c == 't' )
  514.   { functor_t f = (functor_t) loadXR(fd);
  515.     term_t c2 = PL_new_term_ref();
  516.     int arity = arityFunctor(f);
  517.     int n;
  518.  
  519.     PL_unify_functor(term, f);
  520.     for(n=0; n < arity; n++)
  521.     { PL_get_arg(n+1, term, c2);
  522.       do_load_qlf_term(fd, vars, c2);
  523.     }
  524.   } else
  525.   { _PL_unify_atomic(term, loadXRc(c, fd));
  526.   }
  527. }
  528.  
  529.  
  530. static void
  531. loadQlfTerm(term_t term, IOSTREAM *fd)
  532. { int nvars;
  533.   Word vars;
  534.  
  535.   DEBUG(3, Putf("Loading from %d ...", Stell(fd)));
  536.   if ( (nvars = getNum(fd)) )
  537.   { term_t *v;
  538.     int n;
  539.  
  540.     vars = alloca(nvars * sizeof(term_t));
  541.     for(n=nvars, v=vars; n>0; n--, v++)
  542.       *v = 0L;
  543.   } else
  544.     vars = NULL;
  545.  
  546.   PL_put_variable(term);
  547.   do_load_qlf_term(fd, vars, term);
  548.   DEBUG(3, Putf("Loaded "); pl_write(term); Putf(" to %d\n", Stell(fd)));
  549. }
  550.  
  551.  
  552. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  553. Load a complete `wic' file.  `toplevel' tells  us  whether  we  are  the
  554. toplevel  file  opened,  and thus should include other `wic' files or we
  555. should ignore the include statements.  `load_options' tells us  to  only
  556. load the options of the toplevel file.
  557.  
  558. All wic files loaded are appended in the  right  order  to  a  chain  of
  559. `states'.  They are written to a new toplevel wic file by openWic().
  560. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  561.  
  562. int
  563. loadWicFile(char *file, int flags)
  564. { IOSTREAM *fd;
  565.   bool rval = TRUE;
  566.   bool tablealloced = FALSE;
  567.   char *owf = wicFile;
  568.  
  569.   if ((fd = Sopen_file(file, "rbr")) == (IOSTREAM *) NULL)
  570.   { if ( flags & QLF_EXESTATE )
  571.       rval = -1;
  572.     else
  573.       fatalError("Can't open %s: %s", file, OsError());
  574.     rval = FALSE;
  575.     goto out;
  576.   }
  577.  
  578.   if ( flags & QLF_EXESTATE )
  579.   { if ( Sseek(fd, -2 * (long)sizeof(long), SIO_SEEK_END) > 0 )
  580.     { long size, magic;
  581.  
  582.       size = getstdw(fd);
  583.       magic = getstdw(fd);
  584.       if ( magic == QLFMAGICNUM )
  585.     Sseek(fd, -2 * (long)sizeof(long) - size, SIO_SEEK_END);
  586.       else
  587.     rval = -1;
  588.     } else
  589.       rval = -1;
  590.   }
  591.  
  592.   if ( rval < 0 )
  593.     goto out;
  594.  
  595.   wicFile = file;
  596.   notifyLoad(file);
  597.  
  598.   if ( (flags & QLF_TOPLEVEL) && !(flags & QLF_OPTIONS) )
  599.   { pushXrIdTable();
  600.     tablealloced    = TRUE;
  601.   }
  602.  
  603.   if ( loadWicFd(file, fd, flags) == FALSE )
  604.   { rval = FALSE;
  605.     goto out;
  606.   }
  607.   if ( (flags & QLF_TOPLEVEL) && !(flags & QLF_OPTIONS) )
  608.   { if (appendState(file) == FALSE)
  609.     { rval = FALSE;
  610.       goto out;
  611.     }
  612.   }
  613.  
  614. out:
  615.   if (fd != (IOSTREAM *) NULL)
  616.     Sclose(fd);
  617.   if ( tablealloced )
  618.   { popXrIdTable();
  619.   }
  620.  
  621.   wicFile = owf;
  622.   notifyLoaded();
  623.  
  624.   return rval;
  625. }
  626.  
  627. #define QLF_MAX_HEADER_LINES 100
  628.  
  629. static bool
  630. loadWicFd(char *file, IOSTREAM *fd, int flags)
  631. { char *s;
  632.   Char c;
  633.   int n;
  634.   char mbuf[100];
  635.   char *savedhome;
  636.  
  637.   for(n=0; n<QLF_MAX_HEADER_LINES; n++)
  638.   { char line[256];
  639.  
  640.     if ( Sfgets(line, sizeof(line), fd) == 0 )
  641.       return fatalError("%s is not a SWI-Prolog intermediate code file", file);
  642.     if ( streq(line, "# End Header\n") )
  643.       break;
  644.   }
  645.   if ( n >= QLF_MAX_HEADER_LINES )
  646.     return fatalError("%s: header script too long (> 100 lines)", file);
  647.  
  648.   s = getMagicString(fd, mbuf, sizeof(mbuf));
  649.   if ( !s || !streq(s, saveMagic) )
  650.     return fatalError("%s is not a SWI-Prolog intermediate code file", file);
  651.  
  652.   if ( getNum(fd) < LOADVERSION )
  653.   { fatalError("Intermediate code file %s has incompatible save version",
  654.            file);
  655.     fail;
  656.   }
  657.  
  658.   if ( (flags & QLF_OPTIONS) && (flags & QLF_TOPLEVEL) )
  659.   { GD->options.localSize    = getNum(fd);
  660.     GD->options.globalSize   = getNum(fd);
  661.     GD->options.trailSize    = getNum(fd);
  662.     GD->options.argumentSize = getNum(fd);
  663.     GD->options.heapSize     = getNum(fd);
  664.     DEBUG(2,
  665.       Sdprintf("local=%ld, global=%ld, trail=%ld, arg=%ld, heap=%ld\n",
  666.            GD->options.localSize, GD->options.globalSize,
  667.            GD->options.trailSize, GD->options.argumentSize,
  668.            GD->options.heapSize
  669.           ));
  670.     GD->options.goal         = store_string(getString(fd) );
  671.     GD->options.topLevel     = store_string(getString(fd) );
  672.     GD->options.initFile     = store_string(getString(fd) );
  673.  
  674.     succeed;
  675.   } else
  676.   { int n;
  677.     for(n=0; n<5; n++)   getNum(fd);
  678.     for(n=0; n<3; n++)   getString(fd);
  679.   }
  680.  
  681.                     /* fix paths for changed home */
  682.   savedhome = getString(fd);
  683.   if ( !systemDefaults.home || streq(savedhome, systemDefaults.home) )
  684.   { qlf_has_moved = FALSE;
  685.   } else
  686.   { qlf_has_moved = TRUE;
  687.     qlf_save_dir = store_string(savedhome);
  688.     qlf_load_dir = systemDefaults.home;
  689.   }
  690.  
  691.   for(;;)
  692.   { c = Getc(fd);
  693.  
  694.     switch( c )
  695.     { case EOF:
  696.       case 'T':                /* trailer */
  697.     succeed;
  698.       case 'W':
  699.     { char *name;
  700.  
  701.       name = store_string(getString(fd) );
  702.       if ( (flags & QLF_TOPLEVEL) )
  703.       { appendState(name);
  704.         pushXrIdTable();        /* has it's own id table! */
  705.         loadWicFile(name, 0);
  706.         popXrIdTable();
  707.       }
  708.       continue;
  709.     }
  710.       case 'X':
  711.         break;
  712.       default:
  713.         { loadStatement(c, fd, FALSE);
  714.       continue;
  715.     }
  716.     }
  717.   }
  718. }
  719.  
  720.  
  721. static bool
  722. loadStatement(int c, IOSTREAM *fd, int skip)
  723. { switch(c)
  724.   { case 'P':
  725.       return loadPredicate(fd, skip);
  726.  
  727.     case 'O':
  728.     { word mname = loadXR(fd);
  729.       Module om = LD->modules.source;
  730.       bool rval;
  731.  
  732.       LD->modules.source = lookupModule(mname);
  733.       rval = loadPredicate(fd, skip);
  734.       LD->modules.source = om;
  735.  
  736.       return rval;
  737.     }
  738.     case 'I':
  739.       return loadImport(fd, skip);
  740.  
  741.     case 'D':
  742.     { fid_t       cid = PL_open_foreign_frame();
  743.       term_t goal = PL_new_term_ref();
  744.       atom_t osf         = source_file_name;
  745.       int  oln         = source_line_no;
  746.  
  747.       source_file_name = (currentSource ? currentSource->name : NULL_ATOM);
  748.       source_line_no   = getNum(fd);
  749.       
  750.       loadQlfTerm(goal, fd);
  751.       DEBUG(1, Sdprintf("Directive: ");
  752.            pl_write(goal);
  753.            Sdprintf("\n"));
  754.       if ( !skip )
  755.       { if ( !callProlog(MODULE_user, goal, FALSE) )
  756.     { Sfprintf(Serror,
  757.            "[WARNING: %s:%d: (loading %s) directive failed: ",
  758.            stringAtom(source_file_name), source_line_no, wicFile);
  759.       pl_write(goal);
  760.       Sfprintf(Serror, "]\n");
  761.     }
  762.       }
  763.       PL_discard_foreign_frame(cid);
  764.       
  765.       source_file_name = osf;
  766.       source_line_no   = oln;
  767.  
  768.       succeed;
  769.     }      
  770.  
  771.     case 'Q':
  772.       return loadPart(fd, NULL, skip);
  773.  
  774.     case 'M':
  775.       return loadInModule(fd, skip);
  776.  
  777.     default:
  778.       return qlfLoadError(fd, "loadStatement()");
  779.   }
  780. }
  781.  
  782.  
  783.  
  784. static bool
  785. loadPredicate(IOSTREAM *fd, int skip)
  786. { Procedure proc;
  787.   Definition def;
  788.   Clause clause;
  789.   functor_t f = (functor_t) loadXR(fd);
  790.  
  791.   notifyPredicate(f);
  792.   proc = lookupProcedure(f, LD->modules.source);
  793.   DEBUG(3, Putf("Loading %s ", procedureName(proc)));
  794.   def = proc->definition;
  795.   def->indexPattern |= NEED_REINDEX;
  796.   if ( !skip )
  797.   { if ( SYSTEM_MODE )
  798.     { set(def, SYSTEM|HIDE_CHILDS|LOCKED);
  799.     }
  800.     if ( currentSource )
  801.       addProcedureSourceFile(currentSource, proc);
  802.   }
  803.  
  804.   for(;;)
  805.   { switch(Getc(fd) )
  806.     { case 'X':
  807.       { unsigned long pattern = getNum(fd);
  808.  
  809.     def->indexPattern = (pattern | NEED_REINDEX);
  810.  
  811.     DEBUG(3, Putf("ok\n"));
  812.     succeed;
  813.       }
  814.       case 'C':
  815.       { Code bp, ep;
  816.  
  817.     DEBUG(3, Sdprintf("."));
  818.     clause = (Clause) allocHeap(sizeof(struct clause));
  819.     clause->line_no = (unsigned short) getNum(fd);
  820.     clearFlags(clause);
  821.     clause->prolog_vars = (short) getNum(fd);
  822.     clause->variables = (short) getNum(fd);
  823.     if ( getNum(fd) == 0 )        /* 0: fact */
  824.       set(clause, UNIT_CLAUSE);
  825.     clause->procedure = proc;
  826.     clause->source_no = (currentSource ? currentSource->index : 0);
  827.     clause->code_size = (short) getNum(fd);
  828.     GD->statistics.codes += clause->code_size;
  829.     clause->codes = (Code) allocHeap(clause->code_size * sizeof(code));
  830.  
  831.     bp = clause->codes;
  832.     ep = bp + clause->code_size;
  833.  
  834.     while( bp < ep )
  835.     { code op = getNum(fd);
  836.       int n = 0;
  837.       int narg = codeTable[op].arguments;
  838.       
  839.       *bp++ = encode(op);
  840.       switch(codeTable[op].argtype)
  841.       { case CA1_PROC:
  842.         { switch(op)
  843.           { case I_CALL:
  844.         case I_DEPART:
  845.         { functor_t f = (functor_t)loadXR(fd);
  846.           *bp++ = (word) lookupProcedure(f, LD->modules.source);
  847.           break;
  848.         }
  849.         default:
  850.           *bp++ = loadXR(fd);
  851.           }
  852.           n++;
  853.           break;
  854.         }
  855.         case CA1_FUNC:
  856.         case CA1_DATA:
  857.           *bp++ = loadXR(fd);
  858.           n++;
  859.           break;
  860.         case CA1_INTEGER:
  861.           *bp++ = getstdw(fd);
  862.           n++;
  863.           break;
  864.         case CA1_FLOAT:
  865.         { union { word w[2]; double f; } v;
  866.           v.f = getReal(fd);
  867.           *bp++ = v.w[0];
  868.           *bp++ = v.w[1];
  869.           n += 2;
  870.           break;
  871.         }
  872.         case CA1_STRING:        /* <n> chars */
  873.         { int l = getNum(fd);
  874.           int lw = (l+sizeof(word))/sizeof(word);
  875.           int pad = (lw*sizeof(word) - l);
  876.           char *s = (char *)&bp[1];
  877.  
  878.           DEBUG(3, Sdprintf("String of %ld bytes\n", l));
  879.           *bp = mkStrHdr(lw, pad);
  880.           bp += lw;
  881.           *bp++ = 0L;
  882.           while(--l >= 0)
  883.         *s++ = Getc(fd);
  884.           n++;
  885.           break;
  886.         }
  887.       }
  888.       for( ; n < narg; n++ )
  889.         *bp++ = getNum(fd);
  890.     }
  891.  
  892.     if ( skip )
  893.       freeClause(clause);
  894.     else
  895.     { assertProcedure(proc, clause, CL_END);
  896.     }
  897.       }
  898.     }
  899.   }
  900. }
  901.  
  902.  
  903. static bool
  904. loadImport(IOSTREAM *fd, int skip)
  905. { Procedure proc = (Procedure) loadXR(fd);
  906.   functor_t functor = proc->definition->functor->functor;
  907.   Procedure old;
  908.  
  909.   if ( !skip )
  910.   { DEBUG(3, Sdprintf("loadImport(): %s into %s\n",
  911.               procedureName(proc), stringAtom(LD->modules.source->name)));
  912.  
  913.     if ( (old = isCurrentProcedure(functor, LD->modules.source)) )
  914.     { if ( old->definition == proc->definition )
  915.     succeed;            /* already done this! */
  916.       
  917.       if ( !isDefinedProcedure(old) )
  918.       { old->definition = proc->definition;
  919.     succeed;
  920.       }
  921.  
  922.       return warning("Failed to import %s into %s", 
  923.              procedureName(proc), 
  924.              stringAtom(LD->modules.source->name) );
  925.     }
  926.     addHTable(LD->modules.source->procedures, (void *)functor, proc);
  927.   }
  928.  
  929.   succeed;
  930. }
  931.  
  932.  
  933. static bool
  934. qlfLoadSource(IOSTREAM *fd)
  935. { char *str = getString(fd);
  936.   long time = getstdw(fd);
  937.   int issys = (Qgetc(fd) == 's') ? TRUE : FALSE;
  938.   atom_t fname;
  939.  
  940.   if ( qlf_has_moved && strprefix(str, qlf_save_dir) )
  941.   { char buf[MAXPATHLEN];
  942.     char *s;
  943.  
  944.     strcpy(buf, qlf_load_dir);
  945.     s = &buf[strlen(buf)];
  946.     *s++ = '/';
  947.     strcpy(s, &str[strlen(qlf_save_dir)]);
  948.     fname = lookupAtom(canonisePath(buf));
  949.   } else
  950.     fname = lookupAtom(canonisePath(str));
  951.  
  952.   DEBUG(1, if ( !streq(stringAtom(fname), str) )
  953.          Sdprintf("Replaced path %s --> %s\n", str, stringAtom(fname)));
  954.  
  955.   currentSource = lookupSourceFile(fname);
  956.   currentSource->time = time;
  957.   currentSource->system = issys;
  958.   startConsult(currentSource);
  959.  
  960.   succeed;
  961. }
  962.  
  963.  
  964. static bool
  965. loadPart(IOSTREAM *fd, Module *module, int skip)
  966. { Module om     = LD->modules.source;
  967.   SourceFile of = currentSource;
  968.   int stchk     = debugstatus.styleCheck;
  969.  
  970.   switch(Qgetc(fd))
  971.   { case 'M':
  972.     { atom_t mname = loadXR(fd);
  973.  
  974.       switch( Qgetc(fd) )
  975.       { case '-':
  976.     { LD->modules.source = lookupModule(mname);
  977.                     /* TBD: clear module? */
  978.       break;
  979.     }
  980.     case 'F':
  981.     { atom_t fname;
  982.       Module m;
  983.  
  984.       qlfLoadSource(fd);
  985.       fname = currentSource->name;
  986.  
  987.       m = lookupModule(mname);
  988.       if ( m->file && m->file != currentSource )
  989.       { warning("%s:\n\tmodule \"%s\" already loaded from \"%s\" (skipped)",
  990.             wicFile, stringAtom(m->name), stringAtom(m->file->name));
  991.         skip = TRUE;
  992.         LD->modules.source = m;
  993.       } else
  994.       { if ( !declareModule(mname, currentSource) )
  995.           fail;
  996.       }
  997.  
  998.       if ( module )
  999.         *module = LD->modules.source;
  1000.  
  1001.       for(;;)
  1002.       { switch(Qgetc(fd))
  1003.         { case 'E':
  1004.           { functor_t f = (functor_t) loadXR(fd);
  1005.  
  1006.         if ( !skip )
  1007.         { Procedure proc = lookupProcedure(f, LD->modules.source);
  1008.  
  1009.           addHTable(LD->modules.source->public, (void *)f, proc);
  1010.         } else
  1011.         { if ( !lookupHTable(m->public, (void *)f) )
  1012.           { FunctorDef fd = valueFunctor(f);
  1013.  
  1014.             warning("%s: skipped module \"%s\" lacks %s/%d",
  1015.                 wicFile,
  1016.                 stringAtom(m->name),
  1017.                 stringAtom(fd->name),
  1018.                 fd->arity);
  1019.           }
  1020.         }
  1021.  
  1022.         continue;
  1023.           }
  1024.           case 'X':
  1025.         break;
  1026.           default:
  1027.         return qlfLoadError(fd, "loadPart()");
  1028.         }
  1029.         break;
  1030.       }
  1031.       break;
  1032.     }
  1033.     default:
  1034.       qlfLoadError(fd, "loadPart()");
  1035.       break;
  1036.       }
  1037.       break;
  1038.     }
  1039.     case 'F':
  1040.     { qlfLoadSource(fd);
  1041.  
  1042.       if ( module )
  1043.     *module = NULL;
  1044.  
  1045.       break;
  1046.     }
  1047.     default:
  1048.       return qlfLoadError(fd, "loadPart()");
  1049.   }
  1050.  
  1051.   for(;;)
  1052.   { int c = Qgetc(fd);
  1053.  
  1054.     switch(c)
  1055.     { case 'X':
  1056.       { LD->modules.source = om;
  1057.     currentSource  = of;
  1058.     debugstatus.styleCheck = stchk;
  1059.     systemMode(debugstatus.styleCheck & DOLLAR_STYLE);
  1060.  
  1061.     succeed;
  1062.       }
  1063.       default:
  1064.     loadStatement(c, fd, skip);
  1065.     }
  1066.   }
  1067. }
  1068.  
  1069.  
  1070. static bool
  1071. loadInModule(IOSTREAM *fd, int skip)
  1072. { word mname = loadXR(fd);
  1073.   Module om = LD->modules.source;
  1074.  
  1075.   LD->modules.source = lookupModule(mname);
  1076.   
  1077.   for(;;)
  1078.   { int c = Qgetc(fd);
  1079.  
  1080.     switch(c)
  1081.     { case 'X':
  1082.       { LD->modules.source = om;
  1083.     succeed;
  1084.       }
  1085.       default:
  1086.     loadStatement(c, fd, skip);
  1087.     }
  1088.   }
  1089. }
  1090.  
  1091.  
  1092.          /*******************************
  1093.          *    WRITING .QLF FILES    *
  1094.          *******************************/
  1095.  
  1096. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1097. The code below handles the creation of `wic' files.  It offers a  number
  1098. of  predicates  which  enables  us  to write the compilation toplevel in
  1099. Prolog.
  1100.  
  1101. Note that we keep track of the `current procedure' to keep  all  clauses
  1102. of a predicate together.
  1103. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1104.  
  1105. static Table savedXRTable;        /* saved XR entries */
  1106. static long  savedXRTableId;        /* next id */
  1107.  
  1108. static void
  1109. putString(register char *s, IOSTREAM *fd)
  1110. { while(*s)
  1111.   { Putc(*s, fd);
  1112.     s++;
  1113.   }
  1114.  
  1115.   Putc(EOS, fd);
  1116. }
  1117.  
  1118.  
  1119. static void
  1120. putAtom(atom_t a, IOSTREAM *fd)
  1121. { putString(stringAtom(a), fd);
  1122. }
  1123.  
  1124.  
  1125. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1126. Number encoding:
  1127.  
  1128.     0 <= n <= 2^6    Direct storage in byte
  1129.     
  1130.  
  1131.  
  1132. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1133.  
  1134. static void
  1135. putNum(long int n, IOSTREAM *fd)
  1136. { if ( n > (1L << 28) || n < -((1L << 28) - 1) )
  1137.     sysError("Argument to putNum() out of range: %ld", n);
  1138.  
  1139.   n &= ~0xc0000000;
  1140.  
  1141.   if ( n < (1L << 5) )
  1142.   { Putc((char) (n & 0x3f), fd);
  1143.   } else if ( n < (1L << 13) )
  1144.   { Putc((char) (((n >> 8) & 0x3f) | (1 << 6)), fd);
  1145.     Putc((char) (n & 0xff), fd);
  1146.   } else if ( n < (1L << 21) )
  1147.   { Putc((char) (((n >> 16) & 0x3f) | (2 << 6)), fd);
  1148.     Putc((char) ((n >> 8) & 0xff), fd);
  1149.     Putc((char) (n & 0xff), fd);
  1150.   } else
  1151.   { Putc((char) (((n >> 24) & 0x3f) | (3 << 6)), fd);
  1152.     Putc((char) ((n >> 16) & 0xff), fd);
  1153.     Putc((char) ((n >> 8) & 0xff), fd);
  1154.     Putc((char) (n & 0xff), fd);
  1155.     return;
  1156.   }
  1157. }
  1158.  
  1159.  
  1160. static void
  1161. putstdw(word w, IOSTREAM *fd)
  1162. {
  1163. #ifndef WORDS_BIGENDIAN
  1164.   union
  1165.   { word         l;
  1166.     unsigned char c[4];
  1167.   } cvrt;
  1168.   word rval;
  1169.  
  1170.   cvrt.l = w;
  1171.   rval = (cvrt.c[0] << 24) |
  1172.          (cvrt.c[1] << 16) |
  1173.      (cvrt.c[2] << 8) |
  1174.       cvrt.c[3];
  1175.   Sputw(rval, fd);
  1176. #else
  1177.   Sputw(w, fd);
  1178. #endif
  1179. }
  1180.  
  1181.  
  1182. static void
  1183. putReal(real f, IOSTREAM *fd)
  1184. { word *s = (word *)&f;
  1185.  
  1186.   DEBUG(3, Sdprintf("putReal(%f)\n", f));
  1187.  
  1188. #ifndef WORDS_BIGENDIAN
  1189.   putstdw(s[0], fd);
  1190.   putstdw(s[1], fd);
  1191. #else
  1192.   putstdw(s[1], fd);
  1193.   putstdw(s[0], fd);
  1194. #endif
  1195. }
  1196.  
  1197.  
  1198. static void
  1199. saveXR(word xr, IOSTREAM *fd)
  1200. { Symbol s;
  1201.   long id;
  1202.  
  1203.   if ( isTaggedInt(xr) )        /* TBD: switch */
  1204.   { Putc(XR_INT, fd);
  1205.     putNum(valInt(xr), fd);
  1206.     return;
  1207.   } else if ( isBignum(xr) )
  1208.   { Putc(XR_BIGNUM, fd);
  1209.     putstdw(valBignum(xr), fd);
  1210.     return;
  1211.   } else if ( isReal(xr) )
  1212.   { Putc(XR_FLOAT, fd);
  1213.     putReal(valReal(xr), fd);
  1214.     return;
  1215. #if O_STRING
  1216.   } else if ( isString(xr) )
  1217.   { Putc(XR_STRING, fd);
  1218.     putString(valString(xr), fd);
  1219.     return;
  1220. #endif /* O_STRING */
  1221.   }
  1222.  
  1223.   if ( (s = lookupHTable(savedXRTable, (void *)xr)) )
  1224.   { id = (int) s->value;
  1225.     Putc(XR_REF, fd);
  1226.     putNum(id, fd);
  1227.     return;
  1228.   }
  1229.  
  1230.   id = ++savedXRTableId;
  1231.   addHTable(savedXRTable, (void *)xr, (void *)id);
  1232.  
  1233.   if ( isAtom(xr) )
  1234.   { Putc(XR_ATOM, fd);
  1235.     putAtom(xr, fd);
  1236.     DEBUG(3, Putf("XR(%d) = '%s'\n", id, stringAtom(xr)));
  1237.     return;
  1238.   }
  1239.  
  1240.   assert(0);
  1241. }
  1242.  
  1243.  
  1244. static void
  1245. saveXRFunctor(functor_t f, IOSTREAM *fd)
  1246. { Symbol s;
  1247.   long id;
  1248.   FunctorDef fdef;
  1249.  
  1250.   if ( (s = lookupHTable(savedXRTable, (void *)f)) )
  1251.   { id = (int) s->value;
  1252.     Putc(XR_REF, fd);
  1253.     putNum(id, fd);
  1254.     return;
  1255.   }
  1256.  
  1257.   id = ++savedXRTableId;
  1258.   addHTable(savedXRTable, (void *)f, (void *)id);
  1259.   fdef = valueFunctor(f);
  1260.  
  1261.   Putc(XR_FUNCTOR, fd);
  1262.   saveXR(fdef->name, fd);
  1263.   putNum(fdef->arity, fd);
  1264.   DEBUG(3, Putf("XR(%d) = %s/%d\n", id, stringAtom(fdef->name), fdef->arity));
  1265. }
  1266.  
  1267.  
  1268. static void
  1269. saveXRProc(Procedure p, IOSTREAM *fd)
  1270. { Symbol s;
  1271.   long id;
  1272.  
  1273.   if ( (s = lookupHTable(savedXRTable, p)) )
  1274.   { id = (int) s->value;
  1275.     Putc(XR_REF, fd);
  1276.     putNum(id, fd);
  1277.     return;
  1278.   }
  1279.  
  1280.   id = ++savedXRTableId;
  1281.   addHTable(savedXRTable, p, (void *)id);
  1282.  
  1283.   Putc(XR_PRED, fd);
  1284.   saveXRFunctor(p->definition->functor->functor, fd);
  1285.   saveXR(p->definition->module->name, fd);
  1286.   DEBUG(3, Putf("XR(%d) = proc %s\n", id, procedureName(p)));
  1287. }
  1288.  
  1289.  
  1290. static void
  1291. do_save_qlf_term(Word t, IOSTREAM *fd)
  1292. { deRef(t);
  1293.  
  1294.   if ( isTerm(*t) )
  1295.   { functor_t f = functorTerm(*t);
  1296.  
  1297.     if ( f == FUNCTOR_var1 )
  1298.     { int id = valInt(argTerm(*t, 0));
  1299.  
  1300.       Putc('v', fd);
  1301.       putNum(id, fd);
  1302.     } else
  1303.     { Word q = argTermP(*t, 0);
  1304.       int n, arity = arityFunctor(f);
  1305.  
  1306.       Putc('t', fd);
  1307.       saveXRFunctor(f, fd);
  1308.       for(n=0; n < arity; n++, q++)
  1309.     do_save_qlf_term(q, fd);
  1310.     }
  1311.   } else
  1312.   { assert(isAtomic(*t));
  1313.     saveXR(*t, fd);
  1314.   }
  1315. }
  1316.  
  1317.  
  1318. static void
  1319. saveQlfTerm(term_t t, IOSTREAM *fd)
  1320. { int nvars;
  1321.   fid_t cid = PL_open_foreign_frame();
  1322.  
  1323.   DEBUG(3, Putf("Saving "); pl_write(t); Putf(" from %d ... ", Stell(fd)));
  1324.   nvars = numberVars(t, FUNCTOR_var1, 0);
  1325.   putNum(nvars, fd);
  1326.   do_save_qlf_term(valTermRef(t), fd);    /* TBD */
  1327.   DEBUG(3, Putf("to %d\n", Stell(fd)));
  1328.  
  1329.   PL_discard_foreign_frame(cid);
  1330. }
  1331.  
  1332.  
  1333. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1334. saveWicClause()  saves  a  clause  to  the  .qlf  file.   For  predicate
  1335. references of I_CALL and I_DEPART, we  cannot store the predicate itself
  1336. as this would lead to an inconsistency if   the .qlf file is loaded into
  1337. another context module.  Therefore we just   store the functor.  For now
  1338. this is ok as constructs of the   form  module:goal are translated using
  1339. the meta-call mechanism.  This needs consideration   if we optimise this
  1340. (which is not that likely as I    think  module:goal, where `module' is an
  1341. atom,  should  be  restricted  to  very    special  cases  and  toplevel
  1342. interaction.
  1343. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1344.  
  1345. static void
  1346. saveWicClause(Clause clause, IOSTREAM *fd)
  1347. { Code bp, ep;
  1348.  
  1349.   Putc('C', fd);
  1350.   putNum(clause->line_no, fd);
  1351.   putNum(clause->prolog_vars, fd);
  1352.   putNum(clause->variables, fd);
  1353.   putNum(true(clause, UNIT_CLAUSE) ? 0 : 1, fd);
  1354.   putNum(clause->code_size, fd);
  1355.  
  1356.   bp = clause->codes;
  1357.   ep = bp + clause->code_size;
  1358.  
  1359.   while( bp < ep )
  1360.   { code op = decode(*bp++);
  1361.     int n = 0;
  1362.  
  1363.     putNum(op, fd);
  1364.     switch(codeTable[op].argtype)
  1365.     { case CA1_PROC:
  1366.       { Procedure p = (Procedure) *bp++;
  1367.     n++;
  1368.     switch(op)
  1369.     { case I_CALL:
  1370.       case I_DEPART:
  1371.         saveXRFunctor(p->definition->functor->functor, fd);
  1372.         break;
  1373.       default:
  1374.         saveXRProc(p, fd);
  1375.     }
  1376.     break;
  1377.       }
  1378.       case CA1_FUNC:
  1379.       { functor_t f = (functor_t) *bp++;
  1380.     n++;
  1381.     saveXRFunctor(f, fd);
  1382.     break;
  1383.       }
  1384.       case CA1_DATA:
  1385.       { word xr = (word) *bp++;
  1386.     n++;
  1387.     saveXR(xr, fd);
  1388.     break;
  1389.       }
  1390.       case CA1_INTEGER:
  1391.       { putstdw(*bp++, fd);
  1392.     n++;
  1393.     break;
  1394.       }
  1395.       case CA1_FLOAT:
  1396.       { union { word w[2]; double f; } v;
  1397.     v.w[0] = *bp++;
  1398.     v.w[1] = *bp++;
  1399.     n += 2;
  1400.     putReal(v.f, fd);
  1401.     break;
  1402.       }
  1403.       case CA1_STRING:
  1404.       { word m = *bp;
  1405.     char *s = (char *)++bp;
  1406.     int wn = wsizeofInd(m);
  1407.     int l = wn*sizeof(word) - padHdr(m);
  1408.     bp += wn;
  1409.  
  1410.     putNum(l, fd);
  1411.     while(--l >= 0)
  1412.       Putc(*s++&0xff, fd);
  1413.     n++;
  1414.     break;
  1415.       }
  1416.     }
  1417.     for( ; n < codeTable[op].arguments; n++ )
  1418.       putNum(*bp++, fd);
  1419.   }
  1420. }
  1421.  
  1422.  
  1423.         /********************************
  1424.         *         COMPILATION           *
  1425.         *********************************/
  1426.  
  1427. static long emulator_size;
  1428.  
  1429. static void
  1430. closeProcedureWic(IOSTREAM *fd)
  1431. { if ( currentProc != (Procedure) NULL )
  1432.   { Putc('X', fd);
  1433.     putNum(currentProc->definition->indexPattern & ~NEED_REINDEX, fd);
  1434.     currentProc = (Procedure) NULL;
  1435.   }
  1436. }
  1437.  
  1438.  
  1439. static int
  1440. copyEmulator(IOSTREAM *out, IOSTREAM *in)
  1441. { long emsize = -1;
  1442.   long sizepos;
  1443.   int n = 0, c;
  1444.  
  1445.   if ( (sizepos = Sseek(in, -2 * (long)sizeof(long), SIO_SEEK_END)) >= 0 )
  1446.   { long size, magic;
  1447.  
  1448.     size = getstdw(in);
  1449.     magic = getstdw(in);
  1450.     if ( magic == QLFMAGICNUM )
  1451.       emsize = sizepos - size;
  1452.     Sseek(in, 0, SIO_SEEK_SET);
  1453.   }
  1454.  
  1455.   while((c=Sgetc(in)) != EOF && n++ != emsize)
  1456.     Sputc(c, out);
  1457.  
  1458.   emulator_size = n;
  1459.  
  1460.   succeed;
  1461. }
  1462.  
  1463. static const opt_spec save_options[] = 
  1464. { { ATOM_local,      OPT_INT },
  1465.   { ATOM_global,     OPT_INT },
  1466.   { ATOM_trail,         OPT_INT },
  1467.   { ATOM_argument,   OPT_INT },
  1468.   { ATOM_goal,       OPT_STRING },
  1469.   { ATOM_toplevel,   OPT_STRING },
  1470.   { ATOM_init_file,  OPT_STRING },
  1471.   { ATOM_tty,         OPT_BOOL },
  1472.   { ATOM_stand_alone,OPT_BOOL },
  1473.   { NULL_ATOM,         0 }
  1474. };
  1475.  
  1476.  
  1477. static bool
  1478. openWic(const char *file, term_t args)
  1479. { char *exec;
  1480.   char tmp[MAXPATHLEN];
  1481.  
  1482.   int   localSize    = GD->options.localSize;
  1483.   int   globalSize   = GD->options.globalSize;
  1484.   int   trailSize    = GD->options.trailSize;
  1485.   int   argumentSize = GD->options.argumentSize;
  1486.   int    heapSize     = GD->options.heapSize;
  1487.   char *goal         = GD->options.goal;
  1488.   char *topLevel     = GD->options.topLevel;
  1489.   char *initFile     = GD->options.initFile;
  1490.   bool  standalone   = FALSE;
  1491.  
  1492.   if ( args )
  1493.   { TRY(scan_options(args, 0, ATOM_save_option, save_options,
  1494.              &localSize,
  1495.              &globalSize,
  1496.              &trailSize,
  1497.              &argumentSize,
  1498.              &goal,
  1499.              &topLevel,
  1500.              &initFile,
  1501.              NULL,
  1502.              &standalone));
  1503.   }
  1504.  
  1505.   wicFile = (char *) file;
  1506.  
  1507.   DEBUG(1, Sdprintf("Open compiler output file %s\n", file));
  1508.   if ( (wicFd = Sopen_file(file, "wbr")) == (IOSTREAM *)NULL )
  1509.     return warning("Can not open %s: %s", file, OsError());
  1510.   mkWicFile = wicFile;
  1511.   DEBUG(1, Sdprintf("Searching for executable\n"));
  1512.   if ( loaderstatus.restored_state )
  1513.   { exec = stringAtom(loaderstatus.restored_state);
  1514.   } else
  1515.   { TRY( getSymbols() );
  1516.     exec = stringAtom(loaderstatus.orgsymbolfile);
  1517.   }
  1518.   DEBUG(1, Sdprintf("Executable = %s\n", exec));
  1519.   if ( !(exec = OsPath(AbsoluteFile(exec, tmp), tmp)) )
  1520.     fail;
  1521.   emulator_size = 0;
  1522.   if ( standalone )
  1523.   { IOSTREAM *exefd;
  1524.  
  1525.     DEBUG(1, Sdprintf("Including executable\n", exec));
  1526.     if ( (exefd = Sopen_file(exec, "rbr")) != NULL )
  1527.     { copyEmulator(wicFd, exefd);
  1528.     } else
  1529.       warning("Can not read emulator %s --- ignoring stand_alone(on)", exec);
  1530.   }      
  1531.  
  1532.   DEBUG(1, Sdprintf("Expanded executable = %s\n", exec));
  1533. /*Sfprintf(wicFd, "#!%s -x\n", exec);*/
  1534. #if OS2
  1535.   Sfprintf(wicFd, "/* Compiled SWI-Prolog Program */\r\n'@ECHO OFF'\r\nparse source . . name\r\n\"%s -x \" name arg(1)\r\nexit\r\n", exec);
  1536. #else
  1537.   Sfprintf(wicFd, "#!/bin/sh\n");
  1538.   Sfprintf(wicFd, "# SWI-Prolog version: %d.%d.%d\n",
  1539.        PLVERSION/10000,
  1540.        (PLVERSION/100)%100,
  1541.        PLVERSION%100);
  1542.   Sfprintf(wicFd, "# SWI-Prolog save-version: %d\n", VERSION);
  1543.   Sfprintf(wicFd, "exec ${SWIPL-%s} -x $0 \"$@\"\n", exec);
  1544.   Sfprintf(wicFd, "# End Header\n");
  1545. #endif /* OS2 */
  1546.   DEBUG(2, Sdprintf("Magic  ...\n"));
  1547.   putString( saveMagic,            wicFd);
  1548.   DEBUG(2, Sdprintf("Numeric options ...\n"));
  1549.   putNum(   VERSION,              wicFd);
  1550.   putNum(   localSize,          wicFd);
  1551.   putNum(   globalSize,         wicFd);
  1552.   putNum(   trailSize,          wicFd);
  1553.   putNum(   argumentSize,       wicFd);
  1554.   putNum(   heapSize,          wicFd);
  1555.   DEBUG(2, Sdprintf("String options ...\n"));
  1556.   putString(goal,                wicFd);
  1557.   putString(topLevel,            wicFd);
  1558.   putString(initFile,              wicFd);
  1559.   if ( systemDefaults.home )
  1560.     putString(systemDefaults.home,  wicFd);
  1561.   else
  1562.     putString("<no home>",  wicFd);
  1563.  
  1564.   currentProc    = (Procedure) NULL;
  1565.   currentSource  = (SourceFile) NULL;
  1566.   savedXRTable   = newHTable(256);
  1567.   savedXRTableId = 0;
  1568.  
  1569.   DEBUG(2, Sdprintf("Header complete ...\n"));
  1570.   succeed;
  1571. }  
  1572.  
  1573.  
  1574. static void
  1575. writeTrailer(IOSTREAM *fd)
  1576. { long size = Stell(fd) - emulator_size;
  1577.  
  1578.   Putc('T', fd);
  1579.   putstdw(size, fd);
  1580.   putstdw(QLFMAGICNUM, fd);
  1581. }
  1582.  
  1583.  
  1584. static bool
  1585. closeWic()
  1586. { bool rval;
  1587.  
  1588.   if (wicFd == (IOSTREAM *) NULL)
  1589.     fail;
  1590.  
  1591.   closeProcedureWic(wicFd);
  1592.   Putc('X', wicFd);
  1593.   destroyHTable(savedXRTable);
  1594.   savedXRTable = NULL;
  1595.   writeTrailer(wicFd);
  1596.   Sclose(wicFd);
  1597.   rval = MarkExecutable(wicFile);
  1598.  
  1599.   wicFd = NULL;
  1600.   wicFile = NULL;
  1601.   mkWicFile = NULL;
  1602.  
  1603.   return rval;
  1604. }
  1605.  
  1606. static bool
  1607. addClauseWic(term_t term, atom_t file)
  1608. { Clause clause;
  1609.   sourceloc loc;
  1610.  
  1611.   loc.file = file;
  1612.   loc.line = source_line_no;
  1613.  
  1614.   if ( (clause = assert_term(term, CL_END, &loc)) )
  1615.   { IOSTREAM *s = wicFd;
  1616.  
  1617.     DEBUG(3, Sdprintf("WAM code:\n");
  1618.          wamListClause(clause));
  1619.  
  1620.     if (clause->procedure != currentProc)
  1621.     { closeProcedureWic(s);
  1622.       currentProc = clause->procedure;
  1623.  
  1624.       if ( clause->procedure->definition->module != LD->modules.source )
  1625.       { Putc('O', s);
  1626.     saveXR(clause->procedure->definition->module->name, s);
  1627.       } else
  1628.       { Putc('P', s);
  1629.       }
  1630.  
  1631.       saveXRFunctor(currentProc->definition->functor->functor, s);
  1632.     }
  1633.     saveWicClause(clause, s);
  1634.     succeed;
  1635.   }
  1636.  
  1637.   Sdprintf("Failed to compile: "); pl_write(term); Sdprintf("\n");
  1638.   fail;
  1639. }
  1640.  
  1641. static bool
  1642. addDirectiveWic(term_t term, IOSTREAM *fd)
  1643. { closeProcedureWic(fd);
  1644.   Putc('D', fd);
  1645.   putNum(source_line_no, fd);
  1646.   saveQlfTerm(term, fd);
  1647.  
  1648.   succeed;
  1649. }  
  1650.  
  1651.  
  1652. static bool
  1653. importWic(Procedure proc, IOSTREAM *fd)
  1654. { closeProcedureWic(fd);
  1655.  
  1656.   Putc('I', fd);
  1657.   saveXRProc(proc, fd);
  1658.  
  1659.   succeed;
  1660. }
  1661.  
  1662.          /*******************************
  1663.          *        PART MARKS        *
  1664.          *******************************/
  1665.  
  1666. typedef struct source_mark *SourceMark;
  1667.  
  1668. struct source_mark
  1669. { long       file_index;
  1670.   SourceMark next;
  1671. };
  1672.  
  1673. static SourceMark source_mark_head = NULL;
  1674. static SourceMark source_mark_tail = NULL;
  1675.  
  1676. static void
  1677. initSourceMarks()
  1678. { source_mark_head = source_mark_tail = NULL;
  1679. }
  1680.  
  1681.  
  1682. static void
  1683. sourceMark(IOSTREAM *s)
  1684. { SourceMark pm = allocHeap(sizeof(struct source_mark));
  1685.  
  1686.   pm->file_index = Stell(s);
  1687.   pm->next = NULL;
  1688.   if ( source_mark_tail )
  1689.   { source_mark_tail->next = pm;
  1690.     source_mark_tail = pm;
  1691.   } else
  1692.   { source_mark_tail = source_mark_head = pm;
  1693.   }
  1694. }
  1695.  
  1696.  
  1697. static int
  1698. writeSourceMarks(IOSTREAM *s)
  1699. { int n = 0;
  1700.   SourceMark pn, pm = source_mark_head;
  1701.  
  1702.   DEBUG(1, Sdprintf("Writing source marks: "));
  1703.  
  1704.   for( ; pm; pm = pn )
  1705.   { pn = pm->next;
  1706.  
  1707.     DEBUG(1, Sdprintf(" %d", pm->file_index));
  1708.     putstdw(pm->file_index, s);
  1709.     freeHeap(pm, sizeof(*pm));
  1710.     n++;
  1711.   }
  1712.   
  1713.   DEBUG(1, Sdprintf("Written %d marks\n", n));
  1714.   putstdw(n, s);
  1715.  
  1716.   return 0;
  1717. }
  1718.  
  1719.  
  1720. static int
  1721. qlfSourceInfo(IOSTREAM *s, long offset, term_t list)
  1722. { char *str;
  1723.   term_t head = PL_new_term_ref();
  1724.  
  1725.   if ( Sseek(s, offset, SIO_SEEK_SET) != offset )
  1726.     return warning("%s: seek failed: %s", wicFile, OsError());
  1727.   if ( Getc(s) != 'F' || !(str=getString(s)) )
  1728.     return warning("QLF format error");
  1729.   
  1730.   return PL_unify_list(list, head, list) &&
  1731.          PL_unify_atom_chars(head, str);
  1732. }
  1733.  
  1734.  
  1735. static word
  1736. qlfInfo(const char *file,
  1737.     term_t cversion, term_t version,
  1738.     term_t files0)
  1739. { IOSTREAM *s = NULL;
  1740.   int lversion;
  1741.   int nqlf, i;
  1742.   long *qlfstart = NULL;
  1743.   word rval = TRUE;
  1744.   term_t files = PL_copy_term_ref(files0);
  1745.  
  1746.   TRY(PL_unify_integer(cversion, VERSION));
  1747.  
  1748.   wicFile = (char *)file;
  1749.  
  1750.   if ( !(s = Sopen_file(file, "rbr")) )
  1751.     return warning("Can't open %s: %s", file, OsError());
  1752.  
  1753.   if ( !(lversion = qlfVersion(s)) )
  1754.   { Sclose(s);
  1755.     fail;
  1756.   }
  1757.     
  1758.   TRY(PL_unify_integer(version, lversion));
  1759.  
  1760.   if ( Sseek(s, -(int)sizeof(long), SIO_SEEK_END) < 0 )
  1761.     return warning("qlf_info/3: seek failed: %s", OsError());
  1762.   nqlf = getstdw(s);
  1763.   DEBUG(1, Sdprintf("Found %d sources at %d starting at", nqlf, rval));
  1764.   qlfstart = (long *)allocHeap(sizeof(long) * nqlf);
  1765.   Sseek(s, -(int)sizeof(long) * (nqlf+1), SIO_SEEK_END);
  1766.   for(i=0; i<nqlf; i++)
  1767.   { qlfstart[i] = getstdw(s);
  1768.     DEBUG(1, Sdprintf(" %d", qlfstart[i]));
  1769.   }
  1770.   DEBUG(1, Sdprintf("\n"));
  1771.  
  1772.   for(i=0; i<nqlf; i++)
  1773.   { if ( !qlfSourceInfo(s, qlfstart[i], files) )
  1774.     { rval = FALSE;
  1775.       goto out;
  1776.     }
  1777.   }
  1778.  
  1779.   rval = PL_unify_nil(files);
  1780.  
  1781. out:
  1782.   if ( qlfstart )
  1783.     freeHeap(qlfstart, sizeof(long) * nqlf);
  1784.   if ( s )
  1785.     Sclose(s);
  1786.  
  1787.   return rval;
  1788. }
  1789.  
  1790.  
  1791.  
  1792. word
  1793. pl_qlf_info(term_t file,
  1794.         term_t cversion, term_t version,
  1795.         term_t files)
  1796. { char *name;
  1797.   char buf[MAXPATHLEN];
  1798.  
  1799.   if ( !(name = PL_get_filename(file, buf, sizeof(buf))) )
  1800.     return warning("qlf_info/3: instantiation fault");
  1801.  
  1802.    return qlfInfo(name, cversion, version, files);
  1803. }
  1804.  
  1805.  
  1806.  
  1807.          /*******************************
  1808.          *    NEW MODULE SUPPORT    *
  1809.          *******************************/
  1810.  
  1811. static bool
  1812. qlfOpen(atom_t name)
  1813. { char *absname;
  1814.   char tmp[MAXPATHLEN];
  1815.  
  1816.   wicFile = stringAtom(name);
  1817.   if ( !(absname = AbsoluteFile(wicFile, tmp)) )
  1818.     fail;
  1819.  
  1820.   if ( !(wicFd = Sopen_file(wicFile, "wbr")) )
  1821.     return warning("qlf_open/1: can't open %s: %s", wicFile, OsError());
  1822.  
  1823.   mkWicFile = wicFile;
  1824.  
  1825.   putString(qlfMagic, wicFd);
  1826.   putNum(VERSION, wicFd);
  1827.   putString(absname, wicFd);
  1828.  
  1829.   currentProc    = (Procedure) NULL;
  1830.   currentSource  = (SourceFile) NULL;
  1831.   savedXRTable   = newHTable(256);
  1832.   savedXRTableId = 0;
  1833.   initSourceMarks();
  1834.  
  1835.   succeed;
  1836. }
  1837.  
  1838.  
  1839. static bool
  1840. qlfClose()
  1841. { IOSTREAM *fd = wicFd;
  1842.  
  1843.   closeProcedureWic(fd);
  1844.   writeSourceMarks(fd);
  1845.   Sclose(fd);
  1846.   wicFd = NULL;
  1847.   mkWicFile = NULL;
  1848.  
  1849.   destroyHTable(savedXRTable);
  1850.   savedXRTable = NULL;
  1851.   
  1852.   succeed;
  1853. }
  1854.  
  1855.  
  1856. static int
  1857. qlfVersion(IOSTREAM *s)
  1858. { char mbuf[100];
  1859.   char *magic;
  1860.  
  1861.   if ( !(magic = getMagicString(s, mbuf, sizeof(mbuf))) ||
  1862.        !streq(magic, qlfMagic) )
  1863.   { Sclose(s);
  1864.     return warning("%s: not a SWI-Prolog .qlf file", wicFile);
  1865.   }
  1866.  
  1867.   return getNum(s);
  1868. }
  1869.  
  1870.  
  1871.  
  1872. static bool
  1873. qlfLoad(char *file, Module *module)
  1874. { IOSTREAM *fd;
  1875.   bool rval;
  1876.   int lversion;
  1877.   char *absloadname;
  1878.   char *abssavename;
  1879.   char tmp[MAXPATHLEN];
  1880.   
  1881.   wicFile = file;
  1882.   if ( !(absloadname = AbsoluteFile(wicFile, tmp)) )
  1883.     fail;
  1884.   
  1885.   if ( !(fd = Sopen_file(file, "rbr")) )
  1886.     return warning("$qlf_load/1: can't open %s: %s", file, OsError());
  1887.   if ( !(lversion = qlfVersion(fd)) || lversion < LOADVERSION )
  1888.   { Sclose(fd);
  1889.     if ( lversion )
  1890.       warning("$qlf_load/1: %s bad version (file version = %d, prolog = %d)",
  1891.           wicFile, lversion, VERSION);
  1892.     fail;
  1893.   }
  1894.  
  1895.   abssavename = getString(fd);
  1896.   if ( streq(absloadname, abssavename) )
  1897.   { qlf_has_moved = FALSE;
  1898.     qlf_load_dir = qlf_save_dir = NULL;
  1899.   } else
  1900.   { char tmp[MAXPATHLEN];
  1901.     qlf_has_moved = TRUE;
  1902.     qlf_load_dir = stringAtom(lookupAtom(DirName(absloadname, tmp)));
  1903.     qlf_save_dir = stringAtom(lookupAtom(DirName(abssavename, tmp)));
  1904.   }
  1905.  
  1906.   if ( Qgetc(fd) != 'Q' )
  1907.     return qlfLoadError(fd, "qlfLoad()");
  1908.  
  1909.   pushXrIdTable();
  1910.   rval = loadPart(fd, module, FALSE);
  1911.   popXrIdTable();
  1912.  
  1913.   Sclose(fd);
  1914.  
  1915.   return rval;
  1916. }
  1917.  
  1918.  
  1919. static bool
  1920. qlfSaveSource(SourceFile f, IOSTREAM *fd)
  1921. { sourceMark(fd);
  1922.   Putc('F', fd);
  1923.   putAtom(f->name, fd);
  1924.   putstdw(f->time, fd);
  1925.   Putc(f->system ? 's' : 'u', fd);
  1926.  
  1927.   currentSource = f;
  1928.  
  1929.   succeed;
  1930. }
  1931.  
  1932.  
  1933. static bool
  1934. qlfStartModule(Module m, IOSTREAM *fd)
  1935. { Symbol s;
  1936.  
  1937.   closeProcedureWic(fd);
  1938.   Putc('Q', fd);
  1939.   Putc('M', fd);
  1940.   saveXR(m->name, fd);
  1941.   if ( m->file )
  1942.     qlfSaveSource(m->file, fd);
  1943.   else
  1944.     Putc('-', fd);
  1945.  
  1946.   for_table(s, m->public)
  1947.   { functor_t f = (functor_t)s->name;
  1948.  
  1949.     Putc('E', fd);
  1950.     saveXRFunctor(f, fd);
  1951.   } 
  1952.  
  1953.   Putc('X', fd);
  1954.  
  1955.   succeed;
  1956. }
  1957.  
  1958.  
  1959. static bool
  1960. qlfStartSubModule(Module m, IOSTREAM *fd)
  1961. { closeProcedureWic(fd);
  1962.   Putc('M', fd);
  1963.   saveXR(m->name, fd);
  1964.  
  1965.   succeed;
  1966. }
  1967.  
  1968.  
  1969. static bool
  1970. qlfStartFile(SourceFile f, IOSTREAM *fd)
  1971. { closeProcedureWic(fd);
  1972.   Putc('Q', fd);
  1973.   qlfSaveSource(f, fd);
  1974.  
  1975.   succeed;
  1976. }
  1977.  
  1978.  
  1979. static bool
  1980. qlfEndPart(IOSTREAM  *fd)
  1981. { closeProcedureWic(fd);
  1982.   Putc('X', fd);
  1983.  
  1984.   succeed;
  1985. }
  1986.  
  1987.  
  1988. word
  1989. pl_qlf_start_module(term_t name)
  1990. { if ( wicFd )
  1991.   { Module m;
  1992.  
  1993.     if ( !PL_get_module(name, &m) )
  1994.       return warning("qlf_start_module/1: argument must be an atom");
  1995.   
  1996.     return qlfStartModule(m, wicFd);
  1997.   }
  1998.  
  1999.   succeed;
  2000. }
  2001.  
  2002.  
  2003. word
  2004. pl_qlf_start_sub_module(term_t name)
  2005. { if ( wicFd )
  2006.   { Module m;
  2007.  
  2008.     if ( !PL_get_module(name, &m) )
  2009.       return warning("qlf_start_sub_module/1: argument must be an atom");
  2010.   
  2011.     return qlfStartSubModule(m, wicFd);
  2012.   }
  2013.  
  2014.   succeed;
  2015. }
  2016.  
  2017.  
  2018. word
  2019. pl_qlf_start_file(term_t name)
  2020. { if ( wicFd )
  2021.   { atom_t a;
  2022.  
  2023.     if ( !PL_get_atom(name, &a) )
  2024.       return warning("qlf_start_file/1: argument must be an atom");
  2025.   
  2026.     return qlfStartFile(lookupSourceFile(a), wicFd);
  2027.   }
  2028.  
  2029.   succeed;
  2030. }
  2031.  
  2032.  
  2033. word
  2034. pl_qlf_end_part()
  2035. { if ( wicFd )
  2036.   { return qlfEndPart(wicFd);
  2037.   }
  2038.  
  2039.   succeed;
  2040. }
  2041.  
  2042.  
  2043. word
  2044. pl_qlf_open(term_t file)
  2045. { atom_t a;
  2046.  
  2047.   if ( PL_get_atom(file, &a) )
  2048.     return qlfOpen(a);
  2049.  
  2050.   return warning("qlf_open/1: instantiation fault");
  2051. }
  2052.  
  2053.  
  2054. word
  2055. pl_qlf_close()
  2056. { return qlfClose();
  2057. }
  2058.  
  2059.  
  2060. word
  2061. pl_qlf_load(term_t file, term_t module)
  2062. { Module m, oldsrc = LD->modules.source;
  2063.   char fbuf[MAXPATHLEN];
  2064.   char *fn;
  2065.   bool rval;
  2066.   term_t name = PL_new_term_ref();
  2067.  
  2068.   if ( !PL_strip_module(file, &m, name) )
  2069.     fail;
  2070.   if ( !(fn = PL_get_filename(name, fbuf, sizeof(fbuf))) )
  2071.     return warning("$qlf_load/2: instantiation fault");
  2072.  
  2073.   rval = qlfLoad(fn, &m);
  2074.   LD->modules.source = oldsrc;
  2075.  
  2076.   if ( !rval )
  2077.     fail;
  2078.  
  2079.   if ( m )
  2080.     return PL_unify_atom(module, m->name);
  2081.   else
  2082.     return PL_unify_integer(module, 0);
  2083. }
  2084.  
  2085.  
  2086.         /********************************
  2087.         *        PROLOG SUPPORT         *
  2088.         *********************************/
  2089.  
  2090. word
  2091. pl_open_wic(term_t name, term_t options)
  2092. { char *file;
  2093.   atom_t fname;
  2094.  
  2095.   if ( !(file = PL_get_filename(name, NULL, 0)) )
  2096.     fail;
  2097.   fname = lookupAtom(file);    /* ensure persistency */
  2098.  
  2099.   return openWic(stringAtom(fname), options);
  2100. }
  2101.  
  2102. word
  2103. pl_qlf_put_states()
  2104. { if ( wicFd )
  2105.     putStates(wicFd);
  2106.  
  2107.   succeed;
  2108. }
  2109.  
  2110.  
  2111. word
  2112. pl_close_wic()
  2113. { return closeWic();
  2114. }
  2115.  
  2116.  
  2117. word
  2118. pl_add_directive_wic(term_t term)
  2119. { if ( wicFd )
  2120.   { if ( PL_is_variable(term) )
  2121.       return warning("$add_directive_wic/1: directive is a variable");
  2122.  
  2123.     return addDirectiveWic(term, wicFd);
  2124.   }
  2125.  
  2126.   succeed;
  2127. }
  2128.  
  2129.  
  2130. word
  2131. pl_import_wic(term_t module, term_t head)
  2132. { if ( wicFd )
  2133.   { Module m;
  2134.     functor_t f;
  2135.  
  2136.     if ( !PL_get_module(module, &m) ||
  2137.      !PL_get_functor(head, &f) )
  2138.       return warning("$import_wic/3: instantiation fault");
  2139.  
  2140.     return importWic(lookupProcedure(f, m), wicFd);
  2141.   }
  2142.  
  2143.   succeed;
  2144. }
  2145.  
  2146.  
  2147. word
  2148. pl_qlf_assert_clause(term_t ref)
  2149. { if ( wicFd )
  2150.   { Clause clause;
  2151.     IOSTREAM *s = wicFd;
  2152.  
  2153.     if ( !PL_get_pointer(ref, (void **)&clause) ||
  2154.      !inCore(clause) || !isClause(clause) )
  2155.       return warning("$qlf_assert_clause/1: Invalid clause reference");
  2156.  
  2157.     if ( clause->procedure != currentProc )
  2158.     { closeProcedureWic(s);
  2159.       currentProc = clause->procedure;
  2160.  
  2161.       if ( clause->procedure->definition->module != LD->modules.source )
  2162.       { Putc('O', s);
  2163.     saveXR(clause->procedure->definition->module->name, s);
  2164.       } else
  2165.       { Putc('P', s);
  2166.       }
  2167.  
  2168.       saveXRFunctor(currentProc->definition->functor->functor, s);
  2169.     }
  2170.  
  2171.     saveWicClause(clause, s);
  2172.   }
  2173.  
  2174.   succeed;
  2175. }
  2176.  
  2177.  
  2178.         /********************************
  2179.         *     BOOTSTRAP COMPILATION     *
  2180.         *********************************/
  2181.  
  2182. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2183. The code below offers a restricted compilation  toplevel  used  for  the
  2184. bootstrap  compilation  (-b  option).  It handles most things the Prolog
  2185. defined compiler handles as well, except:
  2186.  
  2187.   - Be carefull to define  a  predicate  first  before  using  it  as  a
  2188.     directive
  2189.   - It does not offer `consult', `ensure_loaded' or the  list  notation.
  2190.     (there is no way to include other files).
  2191. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2192.  
  2193. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2194. Check whether clause is  of  the  form   :-  directive.  If  so, put the
  2195. directive in directive and succeed. If the   term has no explicit module
  2196. tag, add one from the current source-module.
  2197. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2198.  
  2199. static int
  2200. directiveClause(term_t directive, term_t clause, const char *functor)
  2201. { atom_t name;
  2202.   int arity;
  2203.   term_t d0 = PL_new_term_ref();
  2204.   functor_t f;
  2205.  
  2206.   if ( !PL_get_name_arity(clause, &name, &arity) ||
  2207.        arity != 1 ||
  2208.        !streq(stringAtom(name), functor) )
  2209.     fail;
  2210.  
  2211.   PL_get_arg(1, clause, d0);
  2212.   if ( PL_get_functor(d0, &f) && f == FUNCTOR_module2 )
  2213.     PL_put_term(directive, d0);
  2214.   else
  2215.   { term_t m = PL_new_term_ref();
  2216.  
  2217.     PL_put_atom(m, LD->modules.source->name);
  2218.     PL_cons_functor(directive, FUNCTOR_module2, m, d0);
  2219.   }
  2220.  
  2221.   succeed;
  2222. }
  2223.  
  2224. /*  Compile an entire file into intermediate code.
  2225.  
  2226.  ** Thu Apr 28 13:44:43 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  2227.  
  2228. static bool
  2229. compileFile(char *file)
  2230. { char tmp[MAXPATHLEN];
  2231.   char *path;
  2232.   term_t f = PL_new_term_ref();
  2233.   atom_t nf;
  2234.  
  2235.   DEBUG(1, Sdprintf("Boot compilation of %s\n", file));
  2236.   if ( !(path = AbsoluteFile(file, tmp)) )
  2237.     fail;
  2238.   DEBUG(2, Sdprintf("Expanded to %s\n", path));
  2239.  
  2240.   nf = lookupAtom(path);
  2241.   PL_put_atom(f, nf);
  2242.   DEBUG(2, Sdprintf("Opening\n"));
  2243.   if ( !pl_see(f) )
  2244.     fail;
  2245.   DEBUG(2, Sdprintf("pl_start_consult()\n"));
  2246.   pl_start_consult(f);
  2247.   qlfStartFile(lookupSourceFile(nf), wicFd);
  2248.   
  2249.   for(;;)
  2250.   { fid_t            cid = PL_open_foreign_frame();
  2251.     term_t         t = PL_new_term_ref();
  2252.     term_t directive = PL_new_term_ref();
  2253.     atom_t eof;
  2254.  
  2255.     DEBUG(2, Sdprintf("pl_read_clause() -> "));
  2256.     PL_put_variable(t);
  2257.     if ( !pl_read_clause(t) )        /* syntax error */
  2258.       continue;
  2259.     if ( PL_get_atom(t, &eof) && eof == ATOM_end_of_file )
  2260.       break;
  2261.  
  2262.     DEBUG(2, pl_write(t); pl_nl());
  2263.  
  2264.     if ( directiveClause(directive, t, ":-") )
  2265.     { DEBUG(1, Putf(":- "); pl_write(directive); Putf(".\n") );
  2266.       addDirectiveWic(directive, wicFd);
  2267.       callProlog(MODULE_user, directive, FALSE);
  2268.     } else if ( directiveClause(directive, t, "$:-") )
  2269.     { DEBUG(1, Putf("$:- "); pl_write(directive); Putf(".\n") );
  2270.       callProlog(MODULE_user, directive, FALSE);
  2271.     } else
  2272.       addClauseWic(t, nf);
  2273.  
  2274.     PL_discard_foreign_frame(cid);
  2275.   }
  2276.  
  2277.   qlfEndPart(wicFd);
  2278.   pl_seen();
  2279.  
  2280.   succeed;
  2281. }
  2282.  
  2283. bool
  2284. compileFileList(char *out, int argc, char **argv)
  2285. { newOp("$:-", OP_FX, 1200);
  2286.   TRY(openWic(out, 0) );
  2287.   
  2288.   systemMode(TRUE);
  2289.  
  2290.   for(;argc > 0; argc--, argv++)
  2291.   { if (streq(argv[0], "-c") )
  2292.       break;
  2293.     compileFile(argv[0]);
  2294.   }
  2295.  
  2296.   LD->autoload = TRUE;
  2297.   systemMode(FALSE);
  2298.  
  2299.   { predicate_t pred = PL_predicate("$load_additional_boot_files", 0, "user");
  2300.  
  2301.     PL_call_predicate(MODULE_user, TRUE, pred, 0);
  2302.   }
  2303.  
  2304.   return closeWic();
  2305. }
  2306.  
  2307.  
  2308.         /********************************
  2309.         *         STATE LISTS           *
  2310.         *********************************/
  2311.  
  2312. /*  Add a new state to the chain of states this Prolog session is build
  2313.     from. The file name is made absolute to avoid directory problems
  2314.     with incremental loading.
  2315. */
  2316.  
  2317. static bool
  2318. appendState(const char *name)
  2319. { State state, st;
  2320.   char *absolute;
  2321.   char tmp[MAXPATHLEN];
  2322.  
  2323.   if ((absolute = AbsoluteFile(name, tmp)) == (char *) NULL)
  2324.     return warning("invalid file specification: %s", name);
  2325.  
  2326.   state = (State) allocHeap(sizeof(struct state) );
  2327.   state->next = (State) NULL;
  2328.   state->name = store_string(absolute);
  2329.  
  2330.   if ( !GD->stateList )
  2331.   { GD->stateList = state;
  2332.     succeed;
  2333.   }
  2334.   for(st = GD->stateList; st->next; st = st->next) ;
  2335.   st->next = state;
  2336.  
  2337.   succeed;
  2338. }
  2339.  
  2340. /*  Add 'W' statements to the WIC file for each file in the state list.
  2341. */
  2342.  
  2343. static bool
  2344. putStates(IOSTREAM *fd)
  2345. { State st;
  2346.  
  2347.   for(st = GD->stateList; st; st = st->next)
  2348.   { Putc('W', fd);
  2349.     putString(st->name, fd);
  2350.   }
  2351.  
  2352.   succeed;
  2353. }
  2354.